Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/message/subcls/leftcap.bas

BASIC Source File | 1995-05-31 | 5.8 KB | 180 lines

Option Explicit

Type RECT
   left As Integer
   top As Integer
   right As Integer
   bottom As Integer
End Type

Declare Function GetActiveWindow Lib "User" () As Integer
Declare Function GetWindowDC Lib "User" (ByVal hWnd As Integer) As Integer
Declare Function ReleaseDC Lib "User" (ByVal hWnd As Integer, ByVal hDC As Integer) As Integer
Declare Sub GetWindowRect Lib "User" (ByVal hWnd As Integer, lpRect As RECT)
Declare Sub SetRect Lib "User" (lpRect As RECT, ByVal X1 As Integer, ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer)
Declare Function GetSystemMetrics Lib "User" (ByVal nIndex As Integer) As Integer
Declare Function GetSysColor Lib "User" (ByVal nIndex As Integer) As Long
Declare Function SetTextColor Lib "GDI" (ByVal hDC As Integer, ByVal crColor As Long) As Long
Declare Function SetBkColor Lib "GDI" (ByVal hDC As Integer, ByVal crColor As Long) As Long
Declare Function GetTextExtent Lib "GDI" (ByVal hDC As Integer, ByVal lpString As String, ByVal nCount As Integer) As Long
Declare Function ExtTextOut Lib "GDI" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal wOptions As Integer, lpRect As Any, ByVal lpString As String, ByVal nCount As Integer, lpDx As Any) As Integer

' ExtTextOut attributes
Global Const ETO_GRAYED = 1
Global Const ETO_OPAQUE = 2
Global Const ETO_CLIPPED = 4

' GetSystemMetrics() codes
Global Const SM_CXSCREEN = 0
Global Const SM_CYSCREEN = 1
Global Const SM_CXVSCROLL = 2
Global Const SM_CYHSCROLL = 3
Global Const SM_CYCAPTION = 4
Global Const SM_CXBORDER = 5
Global Const SM_CYBORDER = 6
Global Const SM_CXDLGFRAME = 7
Global Const SM_CYDLGFRAME = 8
Global Const SM_CYVTHUMB = 9
Global Const SM_CXHTHUMB = 10
Global Const SM_CXICON = 11
Global Const SM_CYICON = 12
Global Const SM_CXCURSOR = 13
Global Const SM_CYCURSOR = 14
Global Const SM_CYMENU = 15
Global Const SM_CXFULLSCREEN = 16
Global Const SM_CYFULLSCREEN = 17
Global Const SM_CYKANJIWINDOW = 18
Global Const SM_MOUSEPRESENT = 19
Global Const SM_CYVSCROLL = 20
Global Const SM_CXHSCROLL = 21
Global Const SM_DEBUG = 22
Global Const SM_SWAPBUTTON = 23
Global Const SM_RESERVED1 = 24
Global Const SM_RESERVED2 = 25
Global Const SM_RESERVED3 = 26
Global Const SM_RESERVED4 = 27
Global Const SM_CXMIN = 28
Global Const SM_CYMIN = 29
Global Const SM_CXSIZE = 30
Global Const SM_CYSIZE = 31
Global Const SM_CXFRAME = 32
Global Const SM_CYFRAME = 33
Global Const SM_CXMINTRACK = 34
Global Const SM_CYMINTRACK = 35
Global Const SM_CMETRICS = 36

' System Colors
Global Const COLOR_SCROLLBAR = 0
Global Const COLOR_BACKGROUND = 1
Global Const COLOR_ACTIVECAPTION = 2
Global Const COLOR_INACTIVECAPTION = 3
Global Const COLOR_MENU = 4
Global Const COLOR_WINDOW = 5
Global Const COLOR_WINDOWFRAME = 6
Global Const COLOR_MENUTEXT = 7
Global Const COLOR_WINDOWTEXT = 8
Global Const COLOR_CAPTIONTEXT = 9
Global Const COLOR_ACTIVEBORDER = 10
Global Const COLOR_INACTIVEBORDER = 11
Global Const COLOR_APPWORKSPACE = 12
Global Const COLOR_HIGHLIGHT = 13
Global Const COLOR_HIGHLIGHTTEXT = 14
Global Const COLOR_BTNFACE = 15
Global Const COLOR_BTNSHADOW = 16
Global Const COLOR_GRAYTEXT = 17
Global Const COLOR_BTNTEXT = 18
Global Const COLOR_INACTIVECAPTIONTEXT = 19
Global Const COLOR_BTNHIGHLIGHT = 20

' WM_SIZE message wParam values
Global Const SIZE_RESTORED = 0
Global Const SIZE_MINIMIZED = 1
Global Const SIZE_MAXIMIZED = 2

Sub RefreshCaption (CapText$, Frm As Form, fActive%)
   Dim nRet As Long
   Dim wDC As Integer
   Dim wr As RECT
   Dim xText As Integer
   Dim yText As Integer
   Static xIcon As Integer
   Static yIcon As Integer
   Static xBorder As Integer
   Static yBorder As Integer
   Static BeenHere As Integer
   '
   ' Bail out if form is minimized
   '
   If Frm.WindowState = SIZE_MINIMIZED Then
      Exit Sub
   End If
   '
   ' Retrieve system metrics if first time here
   '
   If Not BeenHere Then
      xIcon = GetSystemMetrics(SM_CXSIZE)
      yIcon = GetSystemMetrics(SM_CYSIZE)
      If Frm.BorderStyle = 1 Then 'FixedSingle
     xBorder = GetSystemMetrics(SM_CXBORDER)
     yBorder = GetSystemMetrics(SM_CYBORDER)
      ElseIf Frm.BorderStyle = 2 Then 'Sizable
     xBorder = GetSystemMetrics(SM_CXFRAME)
     yBorder = GetSystemMetrics(SM_CYFRAME)
      ElseIf Frm.BorderStyle = 3 Then 'FixedDouble
     xBorder = GetSystemMetrics(SM_CXDLGFRAME)
     yBorder = GetSystemMetrics(SM_CYDLGFRAME)
      End If
      BeenHere = True
   End If
   '
   ' Get device context for entire window
   '
   wDC = GetWindowDC(Frm.hWnd)
   '
   ' Determine space required by text
   '
   nRet = GetTextExtent(wDC, CapText, Len(CapText))
   xText = WordLo(nRet)
   yText = WordHi(nRet)
   '
   ' Calc rectangle to put text into
   '
   Call GetWindowRect(Frm.hWnd, wr)
   wr.right = wr.right - wr.left - (xIcon * 2) - xBorder - 2
   wr.left = xBorder + xIcon + 4
   wr.top = yBorder + ((yIcon - yText) \ 2)
   wr.bottom = yBorder + yIcon
   '
   ' Retrieve and set colors to use for titlebar and text
   ' Set background drawing mode
   '
   If fActive Then
      nRet = SetBkColor(wDC, GetSysColor(COLOR_ACTIVECAPTION))
      nRet = SetTextColor(wDC, GetSysColor(COLOR_CAPTIONTEXT))
   Else
      nRet = SetBkColor(wDC, GetSysColor(COLOR_INACTIVECAPTION))
      nRet = SetTextColor(wDC, GetSysColor(COLOR_INACTIVECAPTIONTEXT))
   End If
   '
   ' Draw the caption text
   '
   nRet = ExtTextOut(wDC, wr.left, wr.top, ETO_CLIPPED Or ETO_OPAQUE, wr, CapText, Len(CapText), ByVal 0&)
   '
   ' Release window device context
   '
   nRet = ReleaseDC(Frm.hWnd, wDC)
End Sub

Function WordHi (LongIn&) As Integer
   WordHi = (LongIn And &HFFFF0000) \ &H10000
End Function

Function WordLo (LongIn&) As Integer
   If (LongIn And &HFFFF&) > &H7FFF Then
      WordLo = (LongIn And &HFFFF&) - &H10000
   Else
      WordLo = LongIn And &HFFFF&
   End If
End Function